home *** CD-ROM | disk | FTP | other *** search
/ Night Owl 6 / Night Owl's Shareware - PDSI-006 - Night Owl Corp (1990).iso / 016a / gofer221.zip / SIMPLE < prev    next >
Text File  |  1991-11-20  |  12KB  |  420 lines
  1. --         __________   __________   __________   __________   ________
  2. --        /  _______/  /  ____   /  /  _______/  /  _______/  /  ____  \
  3. --       /  / _____   /  /   /  /  /  /______   /  /______   /  /___/  /
  4. --      /  / /_   /  /  /   /  /  /  _______/  /  _______/  /  __   __/
  5. --     /  /___/  /  /  /___/  /  /  /         /  /______   /  /  \  \ 
  6. --    /_________/  /_________/  /__/         /_________/  /__/    \__\
  7. --
  8. --    Functional programming environment, Version 2.21
  9. --    Copyright Mark P Jones 1991.
  10. --
  11. --    Simplified prelude, without any type classes and overloaded values
  12. --    Based on the Haskell standard prelude version 1.1.
  13. --
  14. --    This prelude file shows one approach to using Gofer without the
  15. --    use of overloaded implementations of show, <=, == etc.
  16. --
  17. --    Needless to say, some (most) of the Gofer demonstration programs
  18. --    cannot be used inconnection with this prelude ... but a wide
  19. --    family of programs can be used without needing to worry about
  20. --    type classes at all.
  21. --
  22.  
  23. -- Operator precedence table
  24.  
  25. infixl 9 !!
  26. infixr 9 .
  27. infixr 8 ^
  28. infixl 7 *
  29. infix  7 /, `div`, `rem`, `mod`
  30. infixl 6 +, -
  31. infix  5 \\
  32. infixr 5 ++, :
  33. infix  4 ==, /=, <, <=, >=, >
  34. infix  4 `elem`, `notElem`
  35. infixr 3 &&
  36. infixr 2 ||
  37.  
  38. -- Standard combinators:
  39.  
  40. const          :: a -> b -> a
  41. const k x       = k
  42.  
  43. id             :: a -> a
  44. id    x         = x
  45.  
  46. curry          :: ((a,b) -> c) -> a -> b -> c
  47. curry f a b     =  f (a,b)
  48.  
  49. uncurry        :: (a -> b -> c) -> (a,b) -> c
  50. uncurry f (a,b) = f a b
  51.  
  52. fst            :: (a,b) -> a
  53. fst (x,y)       = x
  54.  
  55. snd            :: (a,b) -> b
  56. snd (x,y)       = y
  57.  
  58. (.)           :: (b -> c) -> (a -> b) -> (a -> c)
  59. (f . g) x       = f (g x)
  60.  
  61. flip           :: (a -> b -> c) -> b -> a -> c
  62. flip  f x y     =  f y x
  63.  
  64. -- Boolean functions:
  65.  
  66. (&&), (||)     :: Bool -> Bool -> Bool
  67. False && x      = False
  68. True  && x      = x
  69.  
  70. False || x      = x
  71. True  || x      = True
  72.  
  73. not            :: Bool -> Bool
  74. not True        = False
  75. not False       = True
  76.  
  77. otherwise      :: Bool
  78. otherwise       = True
  79.  
  80. -- Essentials and builtin primitives:
  81.  
  82. primitive ord "primCharToInt" :: Char -> Int
  83. primitive chr "primIntToChar" :: Int -> Char
  84.  
  85. primitive (==) "primGenericEq",
  86.           (/=) "primGenericNe",
  87.           (<=) "primGenericLe",
  88.           (<)  "primGenericLt",
  89.           (>=) "primGenericGe",
  90.           (>)  "primGenericGt"  :: a -> a -> Bool
  91.  
  92. max x y | x >= y    = x
  93.         | otherwise = y
  94. min x y | x <= y    = x
  95.         | otherwise = y
  96.  
  97. enumFrom n           = iterate (1+) n                   -- [n..]
  98. enumFromThen n m     = iterate ((m-n)+) n               -- [n,m..]
  99. enumFromTo n m       = takeWhile (m>=) (enumFrom n)           -- [n..m]
  100. enumFromThenTo n o m = takeWhile ((if o>=n then (>=) else (<=)) m) -- [n,o..m]
  101.                                  (enumFromThen n o)
  102.  
  103. primitive (+)    "primPlusInt",
  104.       (-)    "primMinusInt",
  105.           (/)    "primDivInt",
  106.       div    "primDivInt",
  107.           rem    "primRemInt",
  108.           mod    "primModInt",
  109.       (*)    "primMulInt"   :: Int -> Int -> Int
  110. primitive negate "primNegInt"   :: Int -> Int
  111.  
  112. -- Character functions
  113.  
  114. isAscii c    =  ord c < 128
  115. isControl c  =  c < ' '  || c == '\DEL'
  116. isPrint c    =  c >= ' ' && c <= '~'
  117. isSpace c    =  c == ' ' || c == '\t' || c == '\n' ||
  118.                             c == '\r' || c == '\f' || c == '\v'
  119. isUpper c    =  c >= 'A' && c <= 'Z'
  120. isLower c    =  c >= 'a' && c <= 'z'
  121. isAlpha c    =  isUpper c || isLower c
  122. isDigit c    =  c >= '0' && c <= '9'
  123. isAlphanum c =  isAlpha c || isDigit c
  124.  
  125. toUpper c | isLower c  =  chr (ord c - ord 'a' + ord 'A')
  126.           | otherwise  =  c
  127.  
  128. toLower c | isUpper c  =  chr (ord c - ord 'A' + ord 'a')
  129.           | otherwise  =  c
  130.  
  131. subtract   = flip (-)
  132. even x     = x `rem` 2 == 0
  133. odd        = not . even
  134.  
  135. gcd x y    = gcd' (abs x) (abs y)
  136.              where gcd' x 0 = x
  137.                    gcd' x y = gcd' y (x `rem` y)
  138.  
  139. lcm _ 0    = 0
  140. lcm 0 _    = 0
  141. lcm x y    = abs ((x `div` gcd x y) * y)
  142.  
  143. x ^ 0      = 1
  144. x ^ (n+1)  = f x n x
  145.              where f _ 0 y = y
  146.                    f x n y = g x n where
  147.                              g x n | even n    = g (x*x) (n`div`2)
  148.                                    | otherwise = f x (n-1) (x*y)
  149.  
  150. abs x    | x >= 0 = x
  151.          | x <  0 = - x
  152.  
  153. signum x | x == 0 = 0
  154.          | x > 0  = 1
  155.          | x < 0  = -1
  156.  
  157. -- Standard functions
  158.  
  159. until p f x | p x       = x
  160.             | otherwise = until p f (f x)
  161.  
  162. error             :: String -> a
  163. error msg | False  = error msg
  164.  
  165. asTypeOf      :: a -> a -> a
  166. x `asTypeOf` _ = x
  167.  
  168. -- Standard list functions
  169.  
  170. head (x:_)        = x
  171.  
  172. last [x]          = x
  173. last (_:xs)       = last xs
  174.  
  175. tail (_:xs)       = xs
  176.  
  177. init [x]          = []
  178. init (x:xs)       = x : init xs
  179.  
  180. null []           = True
  181. null (_:_)        = False
  182.  
  183. []     ++ ys      = ys
  184. (x:xs) ++ ys      = x:(xs++ys)
  185.  
  186. (\\)              = foldl del
  187.                     where []     `del` _  = []
  188.                           (x:xs) `del` y
  189.                              | x == y     = xs
  190.                              | otherwise  = x : xs `del` y
  191.  
  192. length            = foldl' (\n _ -> n+1) 0
  193.  
  194. (x:_)  !! 0       = x
  195. (_:xs) !! (n+1)   = xs !! n
  196.  
  197. map f []          = []
  198. map f (x:xs)      = f x : map f xs
  199.  
  200. filter _ []       = []
  201. filter p (x:xs)
  202.     | p x         = x : xs'
  203.     | otherwise   = xs'
  204.                   where xs' = filter p xs
  205.  
  206. foldl f z []      = z
  207. foldl f z (x:xs)  = foldl f (f z x) xs
  208.  
  209. foldl1 f (x:xs)   = foldl f x xs
  210.  
  211. scanl f q xs      = q : (case xs of
  212.                          []   -> []
  213.                          x:xs -> scanl f (f q x) xs)
  214.  
  215. scanl1 f (x:xs)   = scanl f x xs
  216.  
  217.  
  218. foldr f z []      = z
  219. foldr f z (x:xs)  = f x (foldr f z xs)
  220.  
  221. foldr1 f [x]      = x
  222. foldr1 f (x:xs)   = f x (foldr1 f xs)
  223.  
  224. scanr f q0 []     = [q0]
  225. scanr f q0 (x:xs) = f x q : qs
  226.                     where qs@(q:_) = scanr f q0 xs
  227.  
  228. scanr1 f [x]      = [x]
  229. scanr1 f (x:xs)   = f x q : qs
  230.                     where qs@(q:_) = scanr1 f xs
  231.  
  232. iterate f x       = x : iterate f (f x)
  233.  
  234. repeat x          = xs where xs = x:xs
  235.  
  236. cycle xs          = xs' where xs' = xs++xs'
  237.  
  238. take 0     _      = []
  239. take _     []     = []
  240. take (n+1) (x:xs) = x : take n xs
  241.  
  242. drop 0     xs     = xs
  243. drop _     []     = []
  244. drop (n+1) (_:xs) = drop n xs
  245.  
  246. splitAt 0     xs     = ([],xs)
  247. splitAt _     []     = ([],[])
  248. splitAt (n+1) (x:xs) = (x:xs',xs'') where (xs',xs'') = splitAt n xs
  249.  
  250. takeWhile p []          = []
  251. takeWhile p (x:xs)
  252.             | p x       = x : takeWhile p xs
  253.             | otherwise = []
  254.  
  255. dropWhile p []          = []
  256. dropWhile p xs@(x:xs')
  257.             | p x       = dropWhile p xs'
  258.             | otherwise = xs
  259.  
  260. span p []               = ([],[])
  261. span p xs@(x:xs')
  262.             | p x       = let (ys,zs) = span p xs' in (x:ys,zs)
  263.             | otherwise = ([],xs)
  264. break p                 = span (not . p)
  265.  
  266. lines ""          = []
  267. lines s           = l : (if null s' then [] else lines (tail s'))
  268.                     where (l, s') = break ('\n'==) s
  269.  
  270. words s           = case dropWhile isSpace s of
  271.                          "" -> []
  272.                          s' -> w : words s''
  273.                                where (w,s'') = break isSpace s'
  274.  
  275. unlines           = concat . map (\l -> l ++ "\n")
  276.  
  277. unwords []        = []
  278. unwords ws        = foldr1 (\w s -> w ++ ' ':s) ws
  279.  
  280. nub []            = []
  281. nub (x:xs)        = x : nub (filter (x/=) xs)
  282.  
  283. reverse           = foldl (flip (:)) []
  284.  
  285. and               = foldr (&&) True
  286. or                = foldr (||) False
  287.  
  288. any p             = or  . map p
  289. all p             = and . map p
  290.  
  291. elem              = any . (==)
  292. notElem           = all . (/=)
  293.  
  294. sum               = foldl' (+) 0
  295. product           = foldl' (*) 1
  296.  
  297. sums              = scanl (+) 0
  298. products          = scanl (*) 1
  299.  
  300. maximum           = foldl1 max
  301. minimum           = foldl1 min
  302.  
  303. concat            = foldr (++) []
  304.  
  305. transpose         = foldr
  306.                       (\xs xss -> zipWith (:) xs (xss ++ repeat []))
  307.                       []
  308.  
  309. zip                       = zipWith  (\a b -> (a,b))
  310. zip3                      = zipWith3 (\a b c -> (a,b,c))
  311. zip4                      = zipWith4 (\a b c d -> (a,b,c,d))
  312. zip5                      = zipWith5 (\a b c d e -> (a,b,c,d,e))
  313. zip6                      = zipWith6 (\a b c d e f -> (a,b,c,d,e,f))
  314. zip7                      = zipWith7 (\a b c d e f g -> (a,b,c,d,e,f,g))
  315.  
  316. zipWith z (a:as) (b:bs)   = z a b : zipWith z as bs
  317. zipWith _ _      _        = []
  318.  
  319. zipWith3 z (a:as) (b:bs) (c:cs)
  320.                           = z a b c : zipWith3 z as bs cs
  321. zipWith3 _ _ _ _          = []
  322.  
  323. zipWith4 z (a:as) (b:bs) (c:cs) (d:ds)
  324.                           = z a b c d : zipWith4 z as bs cs ds
  325. zipWith4 _ _ _ _ _        = []
  326.  
  327. zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es)
  328.                           = z a b c d e : zipWith5 z as bs cs ds es
  329. zipWith5 _ _ _ _ _ _      = []
  330.  
  331. zipWith6 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs)
  332.                           = z a b c d e f : zipWith6 z as bs cs ds es fs
  333. zipWith6 _ _ _ _ _ _ _    = []
  334.  
  335. zipWith7 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs)
  336.                           = z a b c d e f g : zipWith7 z as bs cs ds es fs gs
  337. zipWith7 _ _ _ _ _ _ _ _  = []
  338.  
  339.  
  340. -- Additional B+W/Orwell prelude functions
  341.  
  342. primitive strict    "primStrict" :: (a -> b) -> a -> b
  343. primitive primPrint "primPrint"  :: Int -> a -> String -> String
  344.  
  345. show x                        =  primPrint 0 x []
  346.  
  347. copy n x                      =  take n xs where xs = x:xs
  348.  
  349. foldl' f a []                 =  a
  350. foldl' f a (x:xs)             =  strict (foldl' f) (f a x) xs
  351.  
  352. scanl' f q xs                 = q : (case xs of
  353.                                     []   -> []
  354.                                     x:xs -> strict (scanl' f) (f q x) xs)
  355.  
  356. merge []         ys           =  ys
  357. merge xs         []           =  xs
  358. merge xs'@(x:xs) ys'@(y:ys)
  359.                  | x <= y     =  x : merge xs ys'
  360.                  | otherwise  =  y : merge xs' ys
  361.  
  362. sort                          = foldr insert []
  363. insert x []                   = [x]
  364. insert x (y:ys)  | x <= y     = x:y:ys
  365.                  | otherwise  = y:insert x ys
  366.  
  367. space n         =  copy n ' '
  368.  
  369. qsort []        =  []
  370. qsort (x:xs)    =  qsort [ u | u<-xs, u<x ] ++
  371.                          [ x ] ++
  372.                    qsort [ u | u<-xs, u>=x ]
  373.  
  374. undefined | False =  undefined
  375.  
  376. cjustify n s = space halfm ++ s ++ space (m - halfm)
  377.                where m     = n - length s
  378.                      halfm = m `div` 2
  379. ljustify n s = s ++ space (n - length s)
  380. rjustify n s = space (n - length s) ++ s
  381.  
  382. layn = lay 1
  383.  where lay _ []     = []
  384.        lay n (x:xs) = rjustify 4 (show n) ++ ") " ++ x ++ "\n" ++ lay (n+1) xs
  385.  
  386. -- I/O functions and definitions:
  387. -- This is the minimum required for bootstrapping and execution of
  388. -- interactive programs.
  389.  
  390. data Request  =  -- file system requests:
  391.                 ReadFile      String         
  392.               | WriteFile     String String
  393.               | AppendFile    String String
  394.                  -- channel system requests:
  395.               | ReadChan      String 
  396.               | AppendChan    String String
  397.                  -- environment requests:
  398.               | Echo          Bool
  399.  
  400. data Response = Success
  401.               | Str String 
  402.               | Failure IOError
  403.  
  404. data IOError  = WriteError   String
  405.               | ReadError    String
  406.               | SearchError  String
  407.               | FormatError  String
  408.               | OtherError   String
  409.  
  410. -- Continuation-based I/O:
  411.  
  412. type Dialogue    =  [Response] -> [Request]
  413.  
  414. run        :: (String -> String) -> Dialogue
  415. run f ~(Success : ~(Str kbd : _))
  416.                  = [Echo False, ReadChan "stdin", AppendChan "stdout" (f kbd)]
  417. ---
  418. --- End of Gofer simplified prelude
  419. ---
  420.